home *** CD-ROM | disk | FTP | other *** search
/ Belgian Amiga Club - ADF Collection / BS1 part 60.zip / BS1 part 60 / Kick Pascal v2.10 d2.adf / SYSPROG / ConsoleToolDemo.p < prev    next >
Text File  |  1990-11-01  |  4KB  |  155 lines
  1. Program ConsoleToolDemo;
  2.  
  3. Const
  4.   Length = 80;
  5.  
  6. Type
  7.   String80 = String[80];
  8.  
  9. Var
  10.   Win: Ptr;
  11.   Con: Ptr;
  12.   St: String[80];
  13.   z: Long;
  14.  
  15.  Procedure WriteConInt(Con: ptr;    { Devicehandle }
  16.                        i: Long;     { Zahl, die ausgegeben werden soll }
  17.                        b: integer;  { Basis }
  18.                        f: integer); { Mindest-Feldbreite }
  19.  Var
  20.   s: String[40];
  21.   j,k,z,len: integer;
  22.   i2: Long;
  23.  Begin
  24.   j:=40;
  25.   s[40]:=chr(0);    { Nullbyte am Ende }
  26.   i2:=abs(i);
  27.   Repeat
  28.     j:= j-1;
  29.     z:= i2 mod b;   { letzte Ziffer von i2 }
  30.     If z<10 Then
  31.       s[j]:=chr(z+ord('0'))     { Ziffern 0 bis 10 }
  32.     Else
  33.       s[j]:=chr(z-10+ord('A')); { Hexziffern A bis F }
  34.     i2:= i2 Div b;
  35.   Until i2=0;
  36.   If b=16 Then
  37.     Begin
  38.       j:=j-1;
  39.       s[j]:='$'     { Hexzahlen automatisch mit "$" }
  40.     End;
  41.   If b=2 Then
  42.     Begin
  43.       j:=j-1;
  44.       s[j]:='%'     { Binärzahlen mit "%" }
  45.     End;
  46.   If i<0 Then
  47.     Begin
  48.       j:=j-1;
  49.       s[j]:='-'     { Minuszeichen bei neg. Zahlen }
  50.     End;
  51.   len:=40-j;        { Gesamtlänge der Zahl }
  52.   For k:=1 to f-len Do
  53.     WriteCon(Con, ' ');     { Am Anfang mit Spaces auffüllen }
  54.   WriteCon(Con, Str(^s[j])) { String ab j-tem Zeichen ausgeben }
  55.  End;
  56.  
  57.  Procedure ReadConString(Con:Ptr; Var s: String80);
  58.    Const
  59.      Backspace = chr(8);
  60.      Return = chr(13);
  61.    Var
  62.      ch: Char;
  63.      i: integer;
  64.      Sig: Long;
  65.    Begin
  66.      i:=1;
  67.      Repeat
  68.        Sig:=Wait(-1);
  69.        ch:=ReadCon(Con);
  70.        If ( (ch >= chr(32)) and (ch < chr(127)) ) or (ch>=chr(160)) Then
  71.          Begin
  72.            WriteCon(Con,ch);
  73.            s[i]:=ch;
  74.            i:=i+1
  75.          End;
  76.        If (ch=BackSpace) and (i>1) Then
  77.          Begin
  78.            WriteCon(Con,''\8' '\8);  { Ein Zeichen zurück, mit Space
  79.                                        überschreiben und wieder zurück }
  80.            i:=i-1
  81.          End;
  82.      Until (ch=Return) or (i>=79);
  83.      s[i]:=chr(0);    { mit Space abschließen }
  84.    End;
  85.  
  86.  Function Convert(s: String80): Long;
  87.  Var
  88.    i:Long;
  89.    j, b, z, sign: integer;
  90.  Begin
  91.    i:= 0;
  92.    b:= 10;  { Basis }
  93.    j:= 1;   { Stringanfang }
  94.    While s[j]=' ' Do
  95.      j:=j+1;           { führende Spaces überlesen }
  96.    If s[j]='-' Then
  97.      Begin   { negatives Vorzeichen }
  98.        sign:= -1;
  99.        j:=j+1
  100.      End
  101.    Else
  102.      Begin
  103.        sign:= 1;
  104.        If s[j]='+' Then j:=j+1   { Pluszeichen überlesen }
  105.      End;
  106.    If s[j] = '$' Then   { Hexzahl }
  107.      Begin
  108.        b:=16; j:=j+1
  109.      End;
  110.    If s[j] = '%' Then   { Binärzahl }
  111.      Begin
  112.        b:=2; j:=j+1
  113.      End;
  114.    Repeat
  115.      If (s[j] >= '0') and (s[j] <= '9') Then
  116.        z := ord(s[j]) - ord('0')
  117.      Else
  118.      If (s[j] >= 'a') and (s[j] <= 'z') Then
  119.        z := ord(s[j]) - ord('a') + 10
  120.      Else
  121.      If (s[j] >= 'A') and (s[j] <= 'Z') Then
  122.        z := ord(s[j]) - ord('A') + 10
  123.      Else
  124.        z:= -1;  { ungültige Ziffer }
  125.      If z >= b Then
  126.        z:= -1;  { zu groß für Basis }
  127.      If z >= 0 Then
  128.        i:= b*i + z;
  129.      j:= j+1
  130.    Until z<0;
  131.    Convert:= sign*i
  132.  End;
  133.  
  134.  
  135. Begin
  136.   Win := Open_Window(0,0,640,200,1,0,$1006,'Test',Nil,640,200,640,200);
  137.   Con := OpenConsole(Win);
  138.   Repeat
  139.     WriteCon(Con, 'Eingabe: ');
  140.     ReadConString(Con, St);
  141.     If St <> '' Then
  142.       Begin
  143.         z:=Convert(St);
  144.         WriteCon(Con,''\n\n); { eine Leerzeile }
  145.         WriteConInt(Con, z, 10, 12); { dezimal, rechtsbündig }
  146.         WriteConInt(Con, z, 16, 12);
  147.         WriteCon(Con,'  ');
  148.         WriteConInt(Con, z,  2,  1); { binär und linksbündig }
  149.         WriteCon(Con, ''\n\n)
  150.       End
  151.   Until St='';        { bei Leerzeile beenden }
  152.   CloseConsole(Con);
  153.   Close_Window(Win)
  154. End.
  155.